home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl70b2.lha / tcl7.0b2 / tclProc.c < prev    next >
C/C++ Source or Header  |  1993-07-17  |  16KB  |  615 lines
  1. /* 
  2.  * tclProc.c --
  3.  *
  4.  *    This file contains routines that implement Tcl procedures,
  5.  *    including the "proc" and "uplevel" commands.
  6.  *
  7.  * Copyright (c) 1987-1993 The Regents of the University of California.
  8.  * All rights reserved.
  9.  *
  10.  * Permission is hereby granted, without written agreement and without
  11.  * license or royalty fees, to use, copy, modify, and distribute this
  12.  * software and its documentation for any purpose, provided that the
  13.  * above copyright notice and the following two paragraphs appear in
  14.  * all copies of this software.
  15.  * 
  16.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  17.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  18.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  19.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  20.  *
  21.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  22.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  23.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  24.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  25.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  26.  */
  27.  
  28. #ifndef lint
  29. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclProc.c,v 1.65 93/07/17 14:50:15 ouster Exp $ SPRITE (Berkeley)";
  30. #endif
  31.  
  32. #include "tclInt.h"
  33.  
  34. /*
  35.  * Forward references to procedures defined later in this file:
  36.  */
  37.  
  38. static void    CleanupProc _ANSI_ARGS_((Proc *procPtr));
  39. static  int    InterpProc _ANSI_ARGS_((ClientData clientData,
  40.             Tcl_Interp *interp, int argc, char **argv));
  41. static  void    ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
  42.  
  43. /*
  44.  *----------------------------------------------------------------------
  45.  *
  46.  * Tcl_ProcCmd --
  47.  *
  48.  *    This procedure is invoked to process the "proc" Tcl command.
  49.  *    See the user documentation for details on what it does.
  50.  *
  51.  * Results:
  52.  *    A standard Tcl result value.
  53.  *
  54.  * Side effects:
  55.  *    A new procedure gets created.
  56.  *
  57.  *----------------------------------------------------------------------
  58.  */
  59.  
  60.     /* ARGSUSED */
  61. int
  62. Tcl_ProcCmd(dummy, interp, argc, argv)
  63.     ClientData dummy;            /* Not used. */
  64.     Tcl_Interp *interp;            /* Current interpreter. */
  65.     int argc;                /* Number of arguments. */
  66.     char **argv;            /* Argument strings. */
  67. {
  68.     register Interp *iPtr = (Interp *) interp;
  69.     register Proc *procPtr;
  70.     int result, argCount, i;
  71.     char **argArray = NULL;
  72.     Arg *lastArgPtr;
  73.     register Arg *argPtr = NULL;    /* Initialization not needed, but
  74.                      * prevents compiler warning. */
  75.  
  76.     if (argc != 4) {
  77.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  78.         " name args body\"", (char *) NULL);
  79.     return TCL_ERROR;
  80.     }
  81.  
  82.     procPtr = (Proc *) ckalloc(sizeof(Proc));
  83.     procPtr->iPtr = iPtr;
  84.     procPtr->refCount = 1;
  85.     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
  86.     strcpy(procPtr->command, argv[3]);
  87.     procPtr->argPtr = NULL;
  88.  
  89.     /*
  90.      * Break up the argument list into argument specifiers, then process
  91.      * each argument specifier.
  92.      */
  93.  
  94.     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
  95.     if (result != TCL_OK) {
  96.     goto procError;
  97.     }
  98.     lastArgPtr = NULL;
  99.     for (i = 0; i < argCount; i++) {
  100.     int fieldCount, nameLength, valueLength;
  101.     char **fieldValues;
  102.  
  103.     /*
  104.      * Now divide the specifier up into name and default.
  105.      */
  106.  
  107.     result = Tcl_SplitList(interp, argArray[i], &fieldCount,
  108.         &fieldValues);
  109.     if (result != TCL_OK) {
  110.         goto procError;
  111.     }
  112.     if (fieldCount > 2) {
  113.         ckfree((char *) fieldValues);
  114.         Tcl_AppendResult(interp,
  115.             "too many fields in argument specifier \"",
  116.             argArray[i], "\"", (char *) NULL);
  117.         result = TCL_ERROR;
  118.         goto procError;
  119.     }
  120.     if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
  121.         ckfree((char *) fieldValues);
  122.         Tcl_AppendResult(interp, "procedure \"", argv[1],
  123.             "\" has argument with no name", (char *) NULL);
  124.         result = TCL_ERROR;
  125.         goto procError;
  126.     }
  127.     nameLength = strlen(fieldValues[0]) + 1;
  128.     if (fieldCount == 2) {
  129.         valueLength = strlen(fieldValues[1]) + 1;
  130.     } else {
  131.         valueLength = 0;
  132.     }
  133.     argPtr = (Arg *) ckalloc((unsigned)
  134.         (sizeof(Arg) - sizeof(argPtr->name) + nameLength
  135.         + valueLength));
  136.     if (lastArgPtr == NULL) {
  137.         procPtr->argPtr = argPtr;
  138.     } else {
  139.         lastArgPtr->nextPtr = argPtr;
  140.     }
  141.     lastArgPtr = argPtr;
  142.     argPtr->nextPtr = NULL;
  143.     strcpy(argPtr->name, fieldValues[0]);
  144.     if (fieldCount == 2) {
  145.         argPtr->defValue = argPtr->name + nameLength;
  146.         strcpy(argPtr->defValue, fieldValues[1]);
  147.     } else {
  148.         argPtr->defValue = NULL;
  149.     }
  150.     ckfree((char *) fieldValues);
  151.     }
  152.  
  153.     Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
  154.         ProcDeleteProc);
  155.     ckfree((char *) argArray);
  156.     return TCL_OK;
  157.  
  158.     procError:
  159.     ckfree(procPtr->command);
  160.     while (procPtr->argPtr != NULL) {
  161.     argPtr = procPtr->argPtr;
  162.     procPtr->argPtr = argPtr->nextPtr;
  163.     ckfree((char *) argPtr);
  164.     }
  165.     ckfree((char *) procPtr);
  166.     if (argArray != NULL) {
  167.     ckfree((char *) argArray);
  168.     }
  169.     return result;
  170. }
  171.  
  172. /*
  173.  *----------------------------------------------------------------------
  174.  *
  175.  * TclGetFrame --
  176.  *
  177.  *    Given a description of a procedure frame, such as the first
  178.  *    argument to an "uplevel" or "upvar" command, locate the
  179.  *    call frame for the appropriate level of procedure.
  180.  *
  181.  * Results:
  182.  *    The return value is -1 if an error occurred in finding the
  183.  *    frame (in this case an error message is left in interp->result).
  184.  *    1 is returned if string was either a number or a number preceded
  185.  *    by "#" and it specified a valid frame.  0 is returned if string
  186.  *    isn't one of the two things above (in this case, the lookup
  187.  *    acts as if string were "1").  The variable pointed to by
  188.  *    framePtrPtr is filled in with the address of the desired frame
  189.  *    (unless an error occurs, in which case it isn't modified).
  190.  *
  191.  * Side effects:
  192.  *    None.
  193.  *
  194.  *----------------------------------------------------------------------
  195.  */
  196.  
  197. int
  198. TclGetFrame(interp, string, framePtrPtr)
  199.     Tcl_Interp *interp;        /* Interpreter in which to find frame. */
  200.     char *string;        /* String describing frame. */
  201.     CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
  202.                  * if global frame indicated). */
  203. {
  204.     register Interp *iPtr = (Interp *) interp;
  205.     int curLevel, level, result;
  206.     CallFrame *framePtr;
  207.  
  208.     /*
  209.      * Parse string to figure out which level number to go to.
  210.      */
  211.  
  212.     result = 1;
  213.     curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
  214.     if (*string == '#') {
  215.     if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
  216.         return -1;
  217.     }
  218.     if (level < 0) {
  219.         levelError:
  220.         Tcl_AppendResult(interp, "bad level \"", string, "\"",
  221.             (char *) NULL);
  222.         return -1;
  223.     }
  224.     } else if (isdigit(*string)) {
  225.     if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
  226.         return -1;
  227.     }
  228.     level = curLevel - level;
  229.     } else {
  230.     level = curLevel - 1;
  231.     result = 0;
  232.     }
  233.  
  234.     /*
  235.      * Figure out which frame to use, and modify the interpreter so
  236.      * its variables come from that frame.
  237.      */
  238.  
  239.     if (level == 0) {
  240.     framePtr = NULL;
  241.     } else {
  242.     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  243.         framePtr = framePtr->callerVarPtr) {
  244.         if (framePtr->level == level) {
  245.         break;
  246.         }
  247.     }
  248.     if (framePtr == NULL) {
  249.         goto levelError;
  250.     }
  251.     }
  252.     *framePtrPtr = framePtr;
  253.     return result;
  254. }
  255.  
  256. /*
  257.  *----------------------------------------------------------------------
  258.  *
  259.  * Tcl_UplevelCmd --
  260.  *
  261.  *    This procedure is invoked to process the "uplevel" Tcl command.
  262.  *    See the user documentation for details on what it does.
  263.  *
  264.  * Results:
  265.  *    A standard Tcl result value.
  266.  *
  267.  * Side effects:
  268.  *    See the user documentation.
  269.  *
  270.  *----------------------------------------------------------------------
  271.  */
  272.  
  273.     /* ARGSUSED */
  274. int
  275. Tcl_UplevelCmd(dummy, interp, argc, argv)
  276.     ClientData dummy;            /* Not used. */
  277.     Tcl_Interp *interp;            /* Current interpreter. */
  278.     int argc;                /* Number of arguments. */
  279.     char **argv;            /* Argument strings. */
  280. {
  281.     register Interp *iPtr = (Interp *) interp;
  282.     int result;
  283.     CallFrame *savedVarFramePtr, *framePtr;
  284.  
  285.     if (argc < 2) {
  286.     uplevelSyntax:
  287.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  288.         " ?level? command ?arg ...?\"", (char *) NULL);
  289.     return TCL_ERROR;
  290.     }
  291.  
  292.     /*
  293.      * Find the level to use for executing the command.
  294.      */
  295.  
  296.     result = TclGetFrame(interp, argv[1], &framePtr);
  297.     if (result == -1) {
  298.     return TCL_ERROR;
  299.     }
  300.     argc -= (result+1);
  301.     if (argc == 0) {
  302.     goto uplevelSyntax;
  303.     }
  304.     argv += (result+1);
  305.  
  306.     /*
  307.      * Modify the interpreter state to execute in the given frame.
  308.      */
  309.  
  310.     savedVarFramePtr = iPtr->varFramePtr;
  311.     iPtr->varFramePtr = framePtr;
  312.  
  313.     /*
  314.      * Execute the residual arguments as a command.
  315.      */
  316.  
  317.     if (argc == 1) {
  318.     result = Tcl_Eval(interp, argv[0]);
  319.     } else {
  320.     char *cmd;
  321.  
  322.     cmd = Tcl_Concat(argc, argv);
  323.     result = Tcl_Eval(interp, cmd);
  324.     ckfree(cmd);
  325.     }
  326.     if (result == TCL_ERROR) {
  327.     char msg[60];
  328.     sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
  329.     Tcl_AddErrorInfo(interp, msg);
  330.     }
  331.  
  332.     /*
  333.      * Restore the variable frame, and return.
  334.      */
  335.  
  336.     iPtr->varFramePtr = savedVarFramePtr;
  337.     return result;
  338. }
  339.  
  340. /*
  341.  *----------------------------------------------------------------------
  342.  *
  343.  * TclFindProc --
  344.  *
  345.  *    Given the name of a procedure, return a pointer to the
  346.  *    record describing the procedure.
  347.  *
  348.  * Results:
  349.  *    NULL is returned if the name doesn't correspond to any
  350.  *    procedure.  Otherwise the return value is a pointer to
  351.  *    the procedure's record.
  352.  *
  353.  * Side effects:
  354.  *    None.
  355.  *
  356.  *----------------------------------------------------------------------
  357.  */
  358.  
  359. Proc *
  360. TclFindProc(iPtr, procName)
  361.     Interp *iPtr;        /* Interpreter in which to look. */
  362.     char *procName;        /* Name of desired procedure. */
  363. {
  364.     Tcl_HashEntry *hPtr;
  365.     Command *cmdPtr;
  366.  
  367.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
  368.     if (hPtr == NULL) {
  369.     return NULL;
  370.     }
  371.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  372.     if (cmdPtr->proc != InterpProc) {
  373.     return NULL;
  374.     }
  375.     return (Proc *) cmdPtr->clientData;
  376. }
  377.  
  378. /*
  379.  *----------------------------------------------------------------------
  380.  *
  381.  * TclIsProc --
  382.  *
  383.  *    Tells whether a command is a Tcl procedure or not.
  384.  *
  385.  * Results:
  386.  *    If the given command is actuall a Tcl procedure, the
  387.  *    return value is the address of the record describing
  388.  *    the procedure.  Otherwise the return value is 0.
  389.  *
  390.  * Side effects:
  391.  *    None.
  392.  *
  393.  *----------------------------------------------------------------------
  394.  */
  395.  
  396. Proc *
  397. TclIsProc(cmdPtr)
  398.     Command *cmdPtr;        /* Command to test. */
  399. {
  400.     if (cmdPtr->proc == InterpProc) {
  401.     return (Proc *) cmdPtr->clientData;
  402.     }
  403.     return (Proc *) 0;
  404. }
  405.  
  406. /*
  407.  *----------------------------------------------------------------------
  408.  *
  409.  * InterpProc --
  410.  *
  411.  *    When a Tcl procedure gets invoked, this routine gets invoked
  412.  *    to interpret the procedure.
  413.  *
  414.  * Results:
  415.  *    A standard Tcl result value, usually TCL_OK.
  416.  *
  417.  * Side effects:
  418.  *    Depends on the commands in the procedure.
  419.  *
  420.  *----------------------------------------------------------------------
  421.  */
  422.  
  423. static int
  424. InterpProc(clientData, interp, argc, argv)
  425.     ClientData clientData;    /* Record describing procedure to be
  426.                  * interpreted. */
  427.     Tcl_Interp *interp;        /* Interpreter in which procedure was
  428.                  * invoked. */
  429.     int argc;            /* Count of number of arguments to this
  430.                  * procedure. */
  431.     char **argv;        /* Argument values. */
  432. {
  433.     register Proc *procPtr = (Proc *) clientData;
  434.     register Arg *argPtr;
  435.     register Interp *iPtr = (Interp *) interp;
  436.     char **args;
  437.     CallFrame frame;
  438.     char *value;
  439.     int result;
  440.  
  441.     /*
  442.      * Set up a call frame for the new procedure invocation.
  443.      */
  444.  
  445.     iPtr = procPtr->iPtr;
  446.     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
  447.     if (iPtr->varFramePtr != NULL) {
  448.     frame.level = iPtr->varFramePtr->level + 1;
  449.     } else {
  450.     frame.level = 1;
  451.     }
  452.     frame.argc = argc;
  453.     frame.argv = argv;
  454.     frame.callerPtr = iPtr->framePtr;
  455.     frame.callerVarPtr = iPtr->varFramePtr;
  456.     iPtr->framePtr = &frame;
  457.     iPtr->varFramePtr = &frame;
  458.     iPtr->returnCode = TCL_OK;
  459.  
  460.     /*
  461.      * Match the actual arguments against the procedure's formal
  462.      * parameters to compute local variables.
  463.      */
  464.  
  465.     for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
  466.         argPtr != NULL;
  467.         argPtr = argPtr->nextPtr, args++, argc--) {
  468.  
  469.     /*
  470.      * Handle the special case of the last formal being "args".  When
  471.      * it occurs, assign it a list consisting of all the remaining
  472.      * actual arguments.
  473.      */
  474.  
  475.     if ((argPtr->nextPtr == NULL)
  476.         && (strcmp(argPtr->name, "args") == 0)) {
  477.         if (argc < 0) {
  478.         argc = 0;
  479.         }
  480.         value = Tcl_Merge(argc, args);
  481.         Tcl_SetVar(interp, argPtr->name, value, 0);
  482.         ckfree(value);
  483.         argc = 0;
  484.         break;
  485.     } else if (argc > 0) {
  486.         value = *args;
  487.     } else if (argPtr->defValue != NULL) {
  488.         value = argPtr->defValue;
  489.     } else {
  490.         Tcl_AppendResult(interp, "no value given for parameter \"",
  491.             argPtr->name, "\" to \"", argv[0], "\"",
  492.             (char *) NULL);
  493.         result = TCL_ERROR;
  494.         goto procDone;
  495.     }
  496.     Tcl_SetVar(interp, argPtr->name, value, 0);
  497.     }
  498.     if (argc > 0) {
  499.     Tcl_AppendResult(interp, "called \"", argv[0],
  500.         "\" with too many arguments", (char *) NULL);
  501.     result = TCL_ERROR;
  502.     goto procDone;
  503.     }
  504.  
  505.     /*
  506.      * Invoke the commands in the procedure's body.
  507.      */
  508.  
  509.     procPtr->refCount++;
  510.     result = Tcl_Eval(interp, procPtr->command);
  511.     procPtr->refCount--;
  512.     if (procPtr->refCount <= 0) {
  513.     CleanupProc(procPtr);
  514.     }
  515.     if (result == TCL_RETURN) {
  516.     result = iPtr->returnCode;
  517.     iPtr->returnCode = TCL_OK;
  518.     } else if (result == TCL_ERROR) {
  519.     char msg[100];
  520.  
  521.     /*
  522.      * Record information telling where the error occurred.
  523.      */
  524.  
  525.     sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
  526.         iPtr->errorLine);
  527.     Tcl_AddErrorInfo(interp, msg);
  528.     } else if (result == TCL_BREAK) {
  529.     iPtr->result = "invoked \"break\" outside of a loop";
  530.     result = TCL_ERROR;
  531.     } else if (result == TCL_CONTINUE) {
  532.     iPtr->result = "invoked \"continue\" outside of a loop";
  533.     result = TCL_ERROR;
  534.     }
  535.  
  536.     /*
  537.      * Delete the call frame for this procedure invocation (it's
  538.      * important to remove the call frame from the interpreter
  539.      * before deleting it, so that traces invoked during the
  540.      * deletion don't see the partially-deleted frame).
  541.      */
  542.  
  543.     procDone:
  544.     iPtr->framePtr = frame.callerPtr;
  545.     iPtr->varFramePtr = frame.callerVarPtr;
  546.     TclDeleteVars(iPtr, &frame.varTable);
  547.     return result;
  548. }
  549.  
  550. /*
  551.  *----------------------------------------------------------------------
  552.  *
  553.  * ProcDeleteProc --
  554.  *
  555.  *    This procedure is invoked just before a command procedure is
  556.  *    removed from an interpreter.  Its job is to release all the
  557.  *    resources allocated to the procedure.
  558.  *
  559.  * Results:
  560.  *    None.
  561.  *
  562.  * Side effects:
  563.  *    Memory gets freed, unless the procedure is actively being
  564.  *    executed.  In this case the cleanup is delayed until the
  565.  *    last call to the current procedure completes.
  566.  *
  567.  *----------------------------------------------------------------------
  568.  */
  569.  
  570. static void
  571. ProcDeleteProc(clientData)
  572.     ClientData clientData;        /* Procedure to be deleted. */
  573. {
  574.     Proc *procPtr = (Proc *) clientData;
  575.  
  576.     procPtr->refCount--;
  577.     if (procPtr->refCount <= 0) {
  578.     CleanupProc(procPtr);
  579.     }
  580. }
  581.  
  582. /*
  583.  *----------------------------------------------------------------------
  584.  *
  585.  * CleanupProc --
  586.  *
  587.  *    This procedure does all the real work of freeing up a Proc
  588.  *    structure.  It's called only when the structure's reference
  589.  *    count becomes zero.
  590.  *
  591.  * Results:
  592.  *    None.
  593.  *
  594.  * Side effects:
  595.  *    Memory gets freed.
  596.  *
  597.  *----------------------------------------------------------------------
  598.  */
  599.  
  600. static void
  601. CleanupProc(procPtr)
  602.     register Proc *procPtr;        /* Procedure to be deleted. */
  603. {
  604.     register Arg *argPtr;
  605.  
  606.     ckfree((char *) procPtr->command);
  607.     for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
  608.     Arg *nextPtr = argPtr->nextPtr;
  609.  
  610.     ckfree((char *) argPtr);
  611.     argPtr = nextPtr;
  612.     }
  613.     ckfree((char *) procPtr);
  614. }
  615.